home *** CD-ROM | disk | FTP | other *** search
/ Pascal Super Library / Pascal Super Library (CW International)(1997).bin / TURB_VIS / TVDMX / TVGIZMA.PAS < prev    next >
Pascal/Delphi Source File  |  1994-06-20  |  25KB  |  926 lines
  1.  
  2. {■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■}
  3. {                            }
  4. {    tvGIZMA   --Turbo Vision Accessories        }
  5. {                            }
  6. {    Copyright (c) 1992,94    Randolph Beck        }
  7. {                P.O. Box  56-0487    }
  8. {                Orlando, FL 32856    }
  9. {                CIS:  72361,753        }
  10. {                            }
  11. {■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■}
  12.  
  13. Unit tvGIZMA;
  14.  
  15. {$B-,O+,R-,V-,X+ }
  16.  
  17. interface
  18.  
  19. uses
  20.     Dos, Crt, Objects, Drivers, Memory, Dialogs, Menus,
  21.     HistList, Views, App, MsgBox, RSet, DmxGizma;
  22.  
  23. const
  24.     BeepOn       : boolean = TRUE;    { allows beeping from cmBeep event }
  25.     PreserveScreen : boolean = TRUE;    { restore screen after done }
  26.  
  27.     SoundIndOn        = ' ON';    { On & Off must be the same length }
  28.     SoundIndOff        = 'OFF';
  29.  
  30. type
  31.     PAppA        = ^TAppA;
  32.     PLtdFrame        = ^TLtdFrame;
  33.     PLtdWindow        = ^TLtdWindow;
  34.     PTimeView        = ^TTimeView;
  35.     PUserScreen        = ^TUserScreen;
  36.  
  37.  
  38.     TAppA        =  OBJECT(TApplication)
  39.     Clock        : PTimeView;
  40.     SoundInd    : pstring;
  41.     VideoInd    : pstring;
  42.       constructor Init;
  43.       destructor  Done;  VIRTUAL;
  44.       procedure EventError(var Event: TEvent);  VIRTUAL;
  45.       procedure HandleEvent(var Event: TEvent);  VIRTUAL;
  46.       procedure Idle;  VIRTUAL;
  47.       procedure InitClock;  VIRTUAL;
  48.       function  LoadConfigFile(FName: FNameStr; Header: pstring) : boolean;
  49.       function    NewSoundItem(AHelpCtx: word; ANext: PMenuItem) : PMenuItem;
  50.       function    NewVideoItem(AHelpCtx: word; ANext: PMenuItem) : PMenuItem;
  51.       procedure OutOfMemory;  VIRTUAL;
  52.       procedure ReadConfigData(var S: TStream);  VIRTUAL;
  53.       procedure SaveConfigFile(FName: FNameStr; Header: pstring);
  54.       procedure WriteConfigData(var S: TStream);  VIRTUAL;
  55.       procedure WriteShellMsg;  VIRTUAL;
  56.     end;
  57.  
  58.  
  59.     TLtdFrame        =  OBJECT(TFrame)
  60.       procedure Draw;  VIRTUAL;
  61.     end;
  62.  
  63.  
  64.     TLtdWindow        =  OBJECT(TWindow)
  65.     Limit    : TRect;
  66.       constructor Init(var Bounds,ALimit: TRect; ATitle: TTitleStr; ANumber: integer);
  67.       constructor Load(var S: TStream);
  68.       procedure ChangeBounds(var Bounds: TRect);  VIRTUAL;
  69.       procedure InitFrame;  VIRTUAL;
  70.       procedure Zoom;  VIRTUAL;
  71.     end;
  72.  
  73.  
  74.     TTimeView        =  OBJECT(TView)
  75.     Hour,Min,Sec    : word;
  76.       constructor Init(var Bounds: TRect);
  77.       procedure Draw;  VIRTUAL;
  78.       procedure Update;  VIRTUAL;
  79.     end;
  80.  
  81.  
  82.     TUserScreen        =  OBJECT(TScroller)
  83.       constructor Init(var Bounds: TRect; AHScrollBar,AVScrollBar: PScrollBar);
  84.       procedure Draw;  VIRTUAL;
  85.       procedure HandleEvent(var Event: TEvent);  VIRTUAL;
  86.       function    Valid(Command: word) : boolean;  VIRTUAL;
  87.     end;
  88.  
  89.  
  90.   function  SParam(S: pstring;  Next: pointer) : pointer;
  91.   function  DParam(N: longint;  Next: pointer) : pointer;
  92.     { accessories for FormatStr() and MessageBox() procedures }
  93.  
  94.  
  95.   procedure AssignWinRect(var Bounds: TRect;  MaxX,MaxY: integer);
  96.     { assigns a rectangle which cascades into the desktop }
  97.  
  98.   function  InsertLine(Dialog: PDialog;  Col,Row,Width,Max: integer;
  99.             Fmt: boolean; ALabel: string; HL: word) : PInputLine;
  100.     { inserts a TInputLine view with (optional) history list }
  101.  
  102.   function  InsertText(Dialog: PDialog; Col,Row: integer; AText: string) : PView;
  103.     { inserts a single-line standard text view }
  104.  
  105.   function  NewVarItem(Name, Param: TMenuStr; var Ind: pstring;
  106.             KeyCode, Command, AHelpCtx: word;
  107.             Next: PMenuItem) : PMenuItem;
  108.     { creates a new menu item with a status indicator }
  109.  
  110.   function  wnNextAvail : integer;
  111.     { finds the lowest available window number }
  112.  
  113.   procedure TrimDialog(Window: PWindow);
  114.     { resizes a dialog window }
  115.  
  116.   function  StdMenuHint(AHelpCtx: word) : string;
  117.     { returns a context-sensitive hint string for any the Std????MenuItems
  118.       that were introduced with Turbo Pascal 7.0. }
  119.  
  120.   function  StdWindowHint(AHelpCtx: word) : string;
  121.     { returns a context-sensitive hint string for StdWindowMenuItems }
  122.  
  123.   procedure RegisterTVGizma;
  124.  
  125.  
  126. const
  127.  
  128. {$IFDEF VER60 }
  129.     hcNew    = $FF01;
  130.     hcOpen    = $FF02;
  131.     hcSave    = $FF03;
  132.     hcSaveAs    = $FF04;
  133.     hcSaveAll    = $FF05;
  134.     hcChangeDir    = $FF06;
  135.     hcDosShell    = $FF07;
  136.     hcExit    = $FF08;
  137.  
  138.     hcUndo    = $FF10;
  139.     hcCut    = $FF11;
  140.     hcCopy    = $FF12;
  141.     hcPaste    = $FF13;
  142.     hcClear    = $FF14;
  143.  
  144.     hcTile    = $FF20;
  145.     hcCascade    = $FF21;
  146.     hcCloseAll    = $FF22;
  147.     hcResize    = $FF23;
  148.     hcZoom    = $FF24;
  149.     hcNext    = $FF25;
  150.     hcPrev    = $FF26;
  151.     hcClose    = $FF27;
  152. {$ENDIF }
  153.  
  154.     RLtdFrame    :  TStreamRec = (
  155.     ObjType:  rnLtdFrame;
  156.     VmtLink:  ofs(TypeOf(TLtdFrame)^);
  157.     Load:      @TLtdFrame.Load;
  158.     Store:      @TLtdFrame.Store
  159.       );
  160.  
  161.     RLtdWindow    :  TStreamRec = (
  162.     ObjType:  rnLtdWindow;
  163.     VmtLink:  ofs(TypeOf(TLtdWindow)^);
  164.     Load:      @TLtdWindow.Load;
  165.     Store:      @TLtdWindow.Store
  166.       );
  167.  
  168.  
  169. implementation
  170.  
  171. const    KeptScreen      : PVideoBuf = nil;
  172. var    KeptCol, KeptRow  : byte;
  173.     KeptHeight      : integer;
  174.  
  175.  
  176.   { ══ Param Functions ═══════════════════════════════════════════════════ }
  177.  
  178. const    iparmax            = 15;  { max number of parameters - 1 }
  179.     ipar    : integer    = iparmax;
  180.  
  181. var    Apar    : array[0..iparmax] of pointer;
  182.  
  183.  
  184. function  SParam(S: pstring;  Next: pointer) : pointer;
  185. begin
  186.   {$IFOPT R+ }
  187.   If (ipar < 0) then RunError(201);
  188.   {$ENDIF }
  189.   If (Next = nil) then ipar := iparmax;
  190.   Apar[ipar] := S;
  191.   SParam := @Apar[ipar];
  192.   Dec(ipar);
  193. end;
  194.  
  195.  
  196. function  DParam(N: longint;  Next: pointer) : pointer;
  197. begin
  198.   {$IFOPT R+ }
  199.   If (ipar < 0) then RunError(201);
  200.   {$ENDIF }
  201.   If (Next = nil) then ipar := iparmax;
  202.   Apar[ipar] := pointer(N);
  203.   DParam := @Apar[ipar];
  204.   Dec(ipar);
  205. end;
  206.  
  207.  
  208.   { ══════════════════════════════════════════════════════════════════════ }
  209.  
  210.  
  211. procedure AssignWinRect(var Bounds: TRect;  MaxX,MaxY: integer);
  212. var  P : PView;
  213. begin
  214.  {$IFDEF VER60 }
  215.   DeskTop^.GetExtent(Bounds);
  216.  {$ELSE }
  217.   PApplication(Application)^.GetTileRect(Bounds);
  218.  {$ENDIF }
  219.   P := DeskTop^.Current;
  220.   If (P <> nil) and (P^.Options and ofTileable = 0) then P := nil;
  221.   If (P <> nil) then
  222.     begin
  223.     If (P^.Origin.X >= Bounds.A.X) and (P^.Origin.X < Bounds.B.X) then Bounds.A.X := succ(P^.Origin.X);
  224.     If (P^.Origin.Y >= Bounds.A.Y) and (P^.Origin.Y < Bounds.B.Y) then Bounds.A.Y := succ(P^.Origin.Y);
  225.     If (Bounds.B.X - Bounds.A.X < MinWinSize.X) or
  226.        (Bounds.B.Y - Bounds.A.Y < MinWinSize.Y) then
  227.       begin
  228.      {$IFDEF VER60 }
  229.       DeskTop^.GetExtent(Bounds);
  230.      {$ELSE }
  231.       PApplication(Application)^.GetTileRect(Bounds);
  232.      {$ENDIF }
  233.       end;
  234.     end;
  235.   If (MaxX > 0) and (Bounds.B.X - Bounds.A.X > MaxX) then Bounds.B.X := Bounds.A.X + MaxX;
  236.   If (MaxY > 0) and (Bounds.B.Y - Bounds.A.Y > MaxY) then Bounds.B.Y := Bounds.A.Y + MaxY;
  237. end;
  238.  
  239.  
  240.   { ══════════════════════════════════════════════════════════════════════ }
  241.  
  242.  
  243. function  InsertLine(Dialog: PDialog;    Col,Row,Width,Max: integer;
  244.              Fmt: boolean; ALabel: string;  HL: word) : PInputLine;
  245. var  i    : integer;
  246.      R    : TRect;
  247.      B    : PInputLine;
  248. begin
  249.   With Dialog^ do
  250.     begin
  251.     i  := succ(CStrLen(ALabel));
  252.     R.Assign(Col, Row, Col + Width + 2, succ(Row));
  253.     If (ALabel <> '') then
  254.       begin
  255.       If Fmt then R.Move(1, 1) else R.Move(i, 0);
  256.       end;
  257.     B  := New(PInputLine, Init(R, Max));
  258.     Insert(B);
  259.     If (HL > 0) then
  260.       begin
  261.       R.A.X := R.A.X + Width + 2;
  262.       R.B.X := R.A.X + 3;
  263.       Insert(New(PHistory, Init(R, B, HL)));
  264.       end;
  265.     If (ALabel <> '') then
  266.       begin
  267.       R.Assign(Col, Row, Col + i, succ(Row));
  268.       Insert(New(PLabel, Init(R, ALabel, B)));
  269.       end;
  270.     end;
  271.   InsertLine := B;
  272. end;
  273.  
  274.  
  275.   { ══════════════════════════════════════════════════════════════════════ }
  276.  
  277.  
  278. function  InsertText(Dialog: PDialog; Col,Row: integer; AText: string) : PView;
  279. var  R : TRect;
  280.      B : PView;
  281. begin
  282.   With Dialog^ do
  283.     begin
  284.     R.Assign(Col, Row, Col + length(AText), succ(Row));
  285.     B  := New(PStaticText, Init(R, AText));
  286.     Insert(B);
  287.     end;
  288.   InsertText := B;
  289. end;
  290.  
  291.  
  292.   { ══════════════════════════════════════════════════════════════════════ }
  293.  
  294.  
  295. function  NewVarItem(Name, Param: TMenuStr; var Ind: pstring;
  296.              KeyCode, Command, AHelpCtx: word;
  297.              Next: PMenuItem) : PMenuItem;
  298. var  P : PMenuItem;
  299. begin
  300.   P := NewItem(Name,Param, KeyCode,Command,AHelpCtx, Next);
  301.   Ind := P^.Param;
  302.   NewVarItem := P;
  303. end;
  304.  
  305.  
  306.   { ══════════════════════════════════════════════════════════════════════ }
  307.  
  308.  
  309. function  wnNextAvail : integer;
  310. var  wn : integer;
  311.     function  UsedWN(P: PWindow) : boolean;  far;
  312.     begin
  313.       UsedWN := (P <> PWindow(DeskTop^.Background)) and (P^.Number = wn)
  314.     end;
  315. begin
  316.   wn := 0;
  317.   Repeat Inc(wn) until (DeskTop^.FirstThat(@UsedWN) = nil);
  318.   wnNextAvail := wn;
  319. end;
  320.  
  321.  
  322.   { ══════════════════════════════════════════════════════════════════════ }
  323.  
  324.  
  325. procedure TrimDialog(Window: PWindow);
  326. var  B      : TRect;
  327.      MinX : integer;
  328.     procedure FindBounds(P: PView);  far;
  329.     begin
  330.       If (PFrame(P) <> Window^.Frame) and (P^.GetState(sfVisible)) then
  331.     begin
  332.     If (P^.Origin.X < MinX) then MinX := P^.Origin.X;
  333.     If (P^.Options and ofCenterX <> 0) then P^.MoveTo(0, P^.Origin.Y);
  334.     If (P^.Size.X + P^.Origin.X > B.B.X) then B.B.X := P^.Size.X + P^.Origin.X;
  335.     If (P^.Size.Y + P^.Origin.Y > B.B.Y) then B.B.Y := P^.Size.Y + P^.Origin.Y;
  336.     P^.GrowMode := 0;
  337.     end;
  338.     end;
  339.     procedure ReCenter(P: PView);  far;
  340.     begin
  341.       If (P^.Options and ofCenterX <> 0) and (PFrame(P) <> Window^.Frame) and
  342.      (Window^.Size.X > P^.Size.X) then
  343.     P^.MoveTo(((Window^.Size.X - P^.Size.X) shr 1), P^.Origin.Y);
  344.     end;
  345. begin
  346.   If (Window = nil) then Exit;
  347.   B.Assign(0,0,10,0);
  348.   If (Window^.Title <> nil) then B.B.X := 12 + length(Window^.Title^);
  349.   MinX := 999;
  350.   Window^.ForEach(@FindBounds);
  351.   If (MinX = 999) then MinX := 2;
  352.   B.B.X := B.B.X + MinX + 1;
  353.   B.B.Y := B.B.Y + 1;
  354.   If (B.B.X > Window^.Size.X) then B.B.X := Window^.Size.X;
  355.   If (B.B.Y > Window^.Size.Y) then B.B.Y := Window^.Size.Y;
  356.   Window^.GrowTo(B.B.X, B.B.Y);
  357.   Window^.ForEach(@ReCenter);
  358.   Window^.Options := Window^.Options or ofCentered;
  359.   Window^.DrawView;
  360. end;
  361.  
  362.  
  363.   { ══════════════════════════════════════════════════════════════════════ }
  364.  
  365.  
  366. function  StdMenuHint(AHelpCtx: word) : string;
  367. begin
  368.   Case AHelpCtx of
  369.     hcNew:    StdMenuHint := 'Create a new file in a new window';
  370.     hcOpen:    StdMenuHint := 'Locate and open a file in a new window';
  371.     hcSave:    StdMenuHint := 'Save the file in the active window';
  372.     hcSaveAs:    StdMenuHint := 'Save the current file under a different name, directory or drive';
  373.     hcSaveAll:    StdMenuHint := 'Save all modified files';
  374.     hcChangeDir:StdMenuHint := 'Choose a new default directory';
  375.     hcDosShell:    StdMenuHint := 'Temporarily exit to DOS';
  376.     hcExit:    StdMenuHint := 'Exit program';
  377.  
  378.     hcUndo:    StdMenuHint := 'Undo the previous editor operation';
  379.     hcCut:    StdMenuHint := 'Remove the selected text and put it in the clipboard';
  380.     hcCopy:    StdMenuHint := 'Copy the selected text into the clipboard';
  381.     hcPaste:    StdMenuHint := 'Insert the selected text from the clipboard at the cursor position';
  382.     hcClear:    StdMenuHint := 'Delete the selected text';
  383.  
  384.     hcTile:    StdMenuHint := 'Arrange windows on desktop by tiling';
  385.     hcCascade:    StdMenuHint := 'Arrange windows on desktop by cascading';
  386.     hcCloseAll:    StdMenuHint := 'Close all windows on the desktop';
  387.     hcResize:    StdMenuHint := 'Change the size or position of the active window';
  388.     hcZoom:    StdMenuHint := 'Enlarge or restore the size of the active window';
  389.     hcNext:    StdMenuHint := 'Make the next window active';
  390.     hcPrev:    StdMenuHint := 'Make the previous window active';
  391.     hcClose:    StdMenuHint := 'Close the active window';
  392.    else        StdMenuHint := '';
  393.     end;
  394. end;
  395.  
  396.  
  397. function  StdWindowHint(AHelpCtx: word) : string;
  398. begin
  399.   Case AHelpCtx of
  400.     hcTile:    StdWindowHint := 'Arrange windows on desktop by tiling';
  401.     hcCascade:    StdWindowHint := 'Arrange windows on desktop by cascading';
  402.     hcCloseAll:    StdWindowHint := 'Close all windows on the desktop';
  403.     hcResize:    StdWindowHint := 'Change the size or position of the active window';
  404.     hcZoom:    StdWindowHint := 'Enlarge or restore the size of the active window';
  405.     hcNext:    StdWindowHint := 'Make the next window active';
  406.     hcPrev:    StdWindowHint := 'Make the previous window active';
  407.     hcClose:    StdWindowHint := 'Close the active window';
  408.    else        StdWindowHint := '';
  409.     end;
  410. end;
  411.  
  412.  
  413.   { ══ TAppA ═════════════════════════════════════════════════════════════ }
  414.  
  415.  
  416. constructor TAppA.Init;
  417. begin
  418.   InitMemory;
  419.   InitVideo;
  420.   If PreserveScreen and (StartupMode = ScreenMode) then
  421.     begin
  422.    {$IFDEF VER60 }
  423.     GetBufMem(pointer(KeptScreen), sizeof(TVideoBuf));
  424.    {$ELSE }
  425.     NewCache(pointer(KeptScreen), sizeof(TVideoBuf));
  426.    {$ENDIF }
  427.     If (KeptScreen <> nil) then Move(ScreenBuffer^, KeptScreen^, sizeof(KeptScreen^));
  428.     KeptCol := WhereX;
  429.     KeptRow := WhereY;
  430.     KeptHeight := ScreenHeight;
  431.     end
  432.    else
  433.     KeptScreen := nil;
  434.   InitEvents;
  435.   InitSysError;
  436.   InitHistory;
  437.   TProgram.Init;
  438.   InitClock;
  439.   Insert(Clock);
  440.   If (VideoInd <> nil) then Str(ScreenHeight:length(VideoInd^), VideoInd^);
  441. end;
  442.  
  443.  
  444. destructor TAppA.Done;
  445. begin
  446.   If (Clock <> nil) then Dispose(Clock, Done);
  447.   TProgram.Done;
  448.   DoneHistory;
  449.   DoneSysError;
  450.   DoneEvents;
  451.   DoneVideo;
  452.   If PreserveScreen and (KeptScreen <> nil) then
  453.     begin
  454.     Move(KeptScreen^, ScreenBuffer^, sizeof(KeptScreen^));
  455.     GotoXY(KeptCol, KeptRow);
  456.     end
  457.    else
  458.     PrintStr(#27'[J'^M'   '^M);  { clear screen with ANSI colors if possible }
  459.   If (KeptScreen <> nil) then
  460.     begin
  461.    {$IFDEF VER60 }
  462.     FreeBufMem(KeptScreen);
  463.    {$ELSE }
  464.     DisposeCache(KeptScreen);
  465.    {$ENDIF }
  466.     KeptScreen := nil;
  467.     end;
  468.   DoneMemory;
  469. end;
  470.  
  471.  
  472. procedure TAppA.EventError(var Event: TEvent);
  473. var  k : boolean;
  474. begin
  475.   With Event do
  476.     If (What = evKeyDown) and (Current = PView(DeskTop)) then
  477.       begin
  478.       k := TRUE;
  479.       Case KeyCode of
  480.     kbUp,kbLeft,kbCtrlLeft:        KeyCode := kbShiftTab;
  481.     kbDown,kbRight,kbCtrlRight:    KeyCode := kbTab;
  482.        else                k := FALSE;
  483.     end;
  484.       If k then
  485.     begin
  486.     PutEvent(Event);
  487.     ClearEvent(Event);
  488.     end;
  489.       end;
  490.   If (Event.What <> evNothing) then TApplication.EventError(Event);
  491. end;
  492.  
  493.  
  494. procedure TAppA.HandleEvent(var Event: TEvent);
  495. var  R : TRect;
  496.      M : word;
  497.  
  498.     procedure DeskTopCommand;
  499.     begin
  500.       Desktop^.Lock;
  501.      {$IFDEF VER60 }
  502.       DeskTop^.GetExtent(R);
  503.      {$ELSE }
  504.       GetTileRect(R);
  505.      {$ENDIF }
  506.       Case Event.Command of
  507.     cmCascade:    Desktop^.Cascade(R);
  508.     cmTile:        Desktop^.Tile(R);
  509.     end;
  510.       Message(Desktop, evBroadcast, cmDMX_FixSize, @Self);
  511.       Desktop^.Unlock;
  512.     end;
  513.  
  514.     procedure ShowUserScreen;
  515.     var  Dialog : PDialog;
  516.     begin
  517.       GetExtent(R);
  518.       Dialog := New(PDialog, Init(R, 'User Screen'));
  519.       Dialog^.Insert(New(PUserScreen, Init(R, nil,nil)));
  520.       If (ValidView(Dialog) <> nil) then
  521.     begin
  522.     ExecView(Dialog);
  523.     Dispose(Dialog, Done);
  524.     end;
  525.     end;
  526.  
  527.     procedure DoBeep;
  528.     begin
  529.       If BeepOn then
  530.     begin
  531.     Sound(523);
  532.     Delay(50);
  533.     NoSound;
  534.     end;
  535.     end;
  536.  
  537. begin
  538.   {$IFNDEF VER60 }
  539.   If (Event.What = evCommand) and (Event.Command = cmDosShell) and
  540.      (KeptScreen <> nil)
  541.    then
  542.     begin
  543.     DisposeCache(KeptScreen);
  544.     KeptScreen := nil;
  545.     end;
  546.   {$ENDIF }
  547.   TApplication.HandleEvent(Event);
  548.   If (Event.What = evCommand) then
  549.     begin
  550.     Case Event.Command of
  551.       cmCascade,cmTile:        DeskTopCommand;
  552.       cmBeep,cmDMX_WrongKey:    DoBeep;
  553.       cmToggleSound:
  554.     begin
  555.     BeepOn := not BeepOn;
  556.     If (SoundInd <> nil) then
  557.       begin
  558.       If BeepOn then SoundInd^ := SoundIndOn else SoundInd^ := SoundIndOff;
  559.       end;
  560.     end;
  561.       cmToggleVideo:
  562.     begin
  563.     M := ScreenMode xor smFont8x8;
  564.     If (M and smFont8x8 = 0) then ShadowSize.X := 2 else ShadowSize.X := 1;
  565.     SetScreenMode(M);
  566.     If (VideoInd <> nil) then Str(ScreenHeight:length(VideoInd^), VideoInd^);
  567.     end;
  568.       cmUserScreen:    ShowUserScreen;
  569.      else        Exit;
  570.       end;
  571.     ClearEvent(Event);
  572.     end;
  573. end;
  574.  
  575.  
  576. procedure TAppA.Idle;
  577. var  M : word;
  578.      E : TEvent;
  579.  
  580.     function  IsTileable(P: PView) : boolean;  far;
  581.     begin
  582.       IsTileable := (P^.Options and ofTileable <> 0) and P^.GetState(sfVisible);
  583.     end;
  584.  
  585.   {$IFNDEF VER60 }
  586.     function  IsCloseable(P: PWindow) : boolean;  far;
  587.     begin
  588.       IsCloseable := (pointer(DeskTop^.Background) <> P)
  589.          and (P^.Flags and wfClose <> 0) and P^.GetState(sfVisible);
  590.     end;
  591.   {$ENDIF }
  592.  
  593. begin
  594.   TApplication.Idle;
  595.   If (Desktop^.FirstThat(@IsTileable) <> nil) then
  596.     EnableCommands([cmTile, cmCascade])
  597.    else
  598.     DisableCommands([cmTile, cmCascade]);
  599.  
  600.   {$IFNDEF VER60 }
  601.   If (Desktop^.FirstThat(@IsCloseable) <> nil) then
  602.     EnableCommands([cmCloseAll])
  603.    else
  604.     DisableCommands([cmCloseAll]);
  605.   {$ENDIF }
  606.  
  607.   If (Current = PView(DeskTop)) and (DeskTop^.Current = nil) then
  608.     begin
  609.     E.What    := evCommand;
  610.     E.Command    := cmMenu;
  611.     E.InfoPtr    := @Self;
  612.     PutEvent(E);
  613.     end;
  614.   If (Clock <> nil) then Clock^.Update;
  615. end;
  616.  
  617.  
  618. procedure TAppA.InitClock;
  619. var  R : TRect;
  620. begin
  621.   GetExtent(R);
  622.   Dec(R.B.X);
  623.   R.A.X := R.B.X - 8;
  624.   R.B.Y := R.A.Y + 1;
  625.   Clock := New(PTimeView, Init(R));
  626. end;
  627.  
  628.  
  629. function  TAppA.LoadConfigFile(FName: FNameStr; Header: pstring) : boolean;
  630. var  S    : TBufStream;
  631.      E    : longint;
  632. begin
  633.   S.Init(FName, stOpenRead, 1024);
  634.   If (Header <> nil) then S.Seek(length(Header^));
  635.   If (S.Status = stOK) then ReadConfigData(S);
  636.   If (S.Status <> stOK) and (S.ErrorInfo <> 2) then
  637.     begin
  638.     E := S.ErrorInfo;
  639.     MessageBox('Error (#%d) reading config file.', @E, mfError or mfOKButton);
  640.     end;
  641.   LoadConfigFile := (S.Status = stOK) or (S.ErrorInfo <> 2);
  642.   S.Done;
  643. end;
  644.  
  645.  
  646. function  TAppA.NewSoundItem(AHelpCtx: word; ANext: PMenuItem) : PMenuItem;
  647. begin
  648.   NewSoundItem := NewVarItem('~S~ound', SoundIndOn, SoundInd, kbNoKey,
  649.                 cmToggleSound, AHelpCtx, ANext);
  650. end;
  651.  
  652.  
  653. function  TAppA.NewVideoItem(AHelpCtx: word; ANext: PMenuItem) : PMenuItem;
  654. begin
  655.   If HiResScreen then
  656.     NewVideoItem := NewVarItem('~V~ideo mode', '    ', VideoInd, kbNoKey,
  657.                 cmToggleVideo, AHelpCtx, ANext)
  658.    else
  659.     NewVideoItem := ANext;
  660. end;
  661.  
  662.  
  663. procedure TAppA.OutOfMemory;
  664. begin
  665.   MessageBox('Not enough memory for this operation.', nil, mfError + mfOKButton);
  666. end;
  667.  
  668.  
  669. procedure TAppA.ReadConfigData(var S: TStream);
  670. var  Vid : word;
  671.      Snd : boolean;
  672. begin
  673.   S.Read(Vid, sizeof(Vid));
  674.   S.Read(Snd, sizeof(Snd));
  675.   If (S.Status = stOK) then
  676.     begin
  677.   {$IFNDEF VER60 }
  678.     LoadHistory(S);
  679.   {$ENDIF }
  680.     If (Snd <> BeepOn) then
  681.       begin
  682.       BeepOn := Snd;
  683.       If (SoundInd <> nil) then
  684.     begin
  685.     If BeepOn then SoundInd^ := SoundIndOn else SoundInd^ := SoundIndOff;
  686.     end;
  687.       end;
  688.     If HiResScreen and (Vid <> ScreenMode) then
  689.       begin
  690.       Vid := ScreenMode xor smFont8x8;
  691.       If (Vid and smFont8x8 = 0) then ShadowSize.X := 2 else ShadowSize.X := 1;
  692.       SetScreenMode(Vid);
  693.       If (VideoInd <> nil) then Str(ScreenHeight:length(VideoInd^), VideoInd^);
  694.       end;
  695.     end;
  696. end;
  697.  
  698.  
  699. procedure TAppA.SaveConfigFile(FName: FNameStr; Header: pstring);
  700. var  S    : TBufStream;
  701.      E    : longint;
  702. begin
  703.   S.Init(FName, stCreate, 1024);
  704.   If (Header <> nil) then S.Write(Header^[1], length(Header^));
  705.   If (S.Status = stOK) then WriteConfigData(S);
  706.   If (S.Status <> stOK) then
  707.     begin
  708.     E := S.ErrorInfo;
  709.     MessageBox('Error (#%d) writing config file.', @E, mfError or mfOKButton);
  710.     end;
  711.   S.Done;
  712. end;
  713.  
  714.  
  715. procedure TAppA.WriteConfigData(var S: TStream);
  716. begin
  717.   S.Write(ScreenMode, sizeof(ScreenMode));
  718.   S.Write(BeepOn, sizeof(BeepOn));
  719.   {$IFNDEF VER60 }
  720.   StoreHistory(S);
  721.   {$ENDIF }
  722. end;
  723.  
  724.  
  725. procedure TAppA.WriteShellMsg;
  726. begin
  727.   PrintStr(#27'[J'^M'   '^M'Type EXIT to return to program...'^M^J);
  728. end;
  729.  
  730.  
  731.   { ══ TLtdFrame ═════════════════════════════════════════════════════════ }
  732.  
  733.  
  734. procedure TLtdFrame.Draw;
  735. { draws a zoom icon if the LtdWindow is at maximum size }
  736. var XY : TPoint;
  737. begin
  738.   TFrame.Draw;
  739.   If (State and sfActive <> 0) and (Owner <> nil) and (PWindow(Owner)^.Flags and wfZoom <> 0) then
  740.     begin
  741.     If (PLtdWindow(Owner)^.Limit.B.X > 0) then
  742.       XY.X := PLtdWindow(Owner)^.Limit.B.X else XY.X := Owner^.Owner^.Size.X;
  743.     If (PLtdWindow(Owner)^.Limit.B.Y > 0) then
  744.       XY.Y := PLtdWindow(Owner)^.Limit.B.Y else XY.Y := Owner^.Owner^.Size.Y;
  745.     If (Size.X >= XY.X) and (Size.Y >= XY.Y) then
  746.       WriteStr((Size.X - 4), 0, #18, 5);
  747.     end;
  748. end;
  749.  
  750.  
  751.   { ══ TLtdWindow ════════════════════════════════════════════════════════ }
  752.  
  753.  
  754. constructor TLtdWindow.Init(var Bounds,ALimit    : TRect;
  755.                 ATitle        : TTitleStr;
  756.                 ANumber        : integer);
  757. begin
  758.   TWindow.Init(Bounds, ATitle, ANumber);
  759.   Move(ALimit, Limit, sizeof(Limit));
  760. end;
  761.  
  762.  
  763. constructor TLtdWindow.Load(var S: TStream);
  764. begin
  765.   TWindow.Load(S);
  766.   S.Read(Limit, sizeof(Limit));
  767. end;
  768.  
  769.  
  770. procedure TLtdWindow.ChangeBounds(var Bounds: TRect);
  771. begin
  772.   If (Limit.A.X > 0) and (Bounds.B.X - Bounds.A.X <= Size.X - Limit.A.X) then
  773.     Bounds.B.X := Bounds.A.X + succ(Limit.A.X);
  774.   If (Limit.A.Y > 0) and (Bounds.B.Y - Bounds.A.Y <= Size.Y - Limit.A.Y) then
  775.     Bounds.B.Y := Bounds.A.Y + succ(Limit.A.Y);
  776.   If (Limit.B.X > 0) and (Bounds.B.X - Bounds.A.X > Limit.B.X) then Bounds.B.X := Bounds.A.X + Limit.B.X;
  777.   If (Limit.B.Y > 0) and (Bounds.B.Y - Bounds.A.Y > Limit.B.Y) then Bounds.B.Y := Bounds.A.Y + Limit.B.Y;
  778.   TWindow.ChangeBounds(Bounds);
  779. end;
  780.  
  781.  
  782. procedure TLtdWindow.InitFrame;
  783. var R : TRect;
  784. begin
  785.   GetExtent(R);
  786.   Frame := New(PLtdFrame, Init(R));
  787. end;
  788.  
  789.  
  790. procedure TLtdWindow.Zoom;
  791. var R  : TRect;
  792.     XY : TPoint;
  793. begin
  794.   If (Limit.B.X = 0) or (Limit.B.X > Owner^.Size.X) then
  795.     XY.X := Owner^.Size.X else XY.X := Limit.B.X;
  796.   If (Limit.B.Y = 0) or (Limit.B.Y > Owner^.Size.Y) then
  797.     XY.Y := Owner^.Size.Y else XY.Y := Limit.B.Y;
  798.   If ((Size.X <> XY.X) or (Size.Y <> XY.Y)) then
  799.     begin
  800.     GetBounds(ZoomRect);
  801.     Owner^.GetExtent(R);
  802.     Locate(R);
  803.     end
  804.    else
  805.     Locate(ZoomRect);
  806. end;
  807.  
  808.  
  809.   { ══ TTimeView ═════════════════════════════════════════════════════════ }
  810.  
  811.  
  812. constructor TTimeView.Init(var Bounds: TRect);
  813. begin
  814.   TView.Init(Bounds);
  815.   Min := 99;
  816.   Update;
  817. end;
  818.  
  819.  
  820. procedure TTimeView.Draw;
  821. var  B : TDrawBuffer;
  822.      C : word;
  823.      H : word;
  824.      A,Suffix : string;
  825. begin
  826.   Suffix := ' pm';
  827.   H  := Hour mod 12;
  828.   If (Hour < 12) then Suffix[2] := 'a';
  829.   If (H = 0) then H := 12;
  830.   Str((H * 1000) + Min:5, A);
  831.   A[3] := ':';
  832.   A := A + Suffix;
  833.   C := GetColor(2);
  834.   MoveChar(B, ' ', C, Size.X);
  835.   MoveStr(B, A, C);
  836.   WriteLine(0, 0, Size.X, 1, B);
  837. end;
  838.  
  839.  
  840. procedure TTimeView.Update;
  841. var  H,M,T : word;
  842. begin
  843.   GetTime(H,M,Sec,T);
  844.   If (Hour <> H) or (Min <> M) then
  845.     begin
  846.     Hour := H;
  847.     Min  := M;
  848.     DrawView;
  849.     If (Sec = 0) and (Min in [0,30]) then
  850.       Message(Application, evBroadcast, cmChime, @Self);
  851.     end;
  852. end;
  853.  
  854.  
  855.   { ══ TUserScreen ═══════════════════════════════════════════════════════ }
  856.  
  857.  
  858. constructor TUserScreen.Init(var Bounds: TRect; AHScrollBar,AVScrollBar: PScrollBar);
  859. var  Width,Height : integer;
  860. begin
  861.   TScroller.Init(Bounds, AHScrollBar,AVScrollBar);
  862.   Width  := 80;
  863.   Height := KeptHeight;
  864.   If (StartupMode in [0,1]) then Width := 40;
  865.   SetCursor(pred(KeptCol), pred(KeptRow));
  866.   If (KeptScreen = nil) then Height := 0;
  867.   GrowMode := gfGrowHiX or gfGrowHiY;
  868.   SetLimit(Width,Height);
  869. end;
  870.  
  871.  
  872. procedure TUserScreen.Draw;
  873. var  i, Y : integer;
  874.      B      : TDrawBuffer;
  875. begin
  876.   If (KeptScreen = nil) then Limit.Y := 0;
  877.   For Y := 0 to Size.Y - 1 do
  878.     begin
  879.     FillChar(B, sizeof(B), 0);
  880.     i := Delta.Y + Y;
  881.     If (i < Limit.Y) then
  882.       Move(KeptScreen^[(i * Limit.X) + Delta.X], B, Limit.X shl 1);
  883.     WriteLine(0, Y, Size.X, 1, B);
  884.     end;
  885.   If (Limit.Y > 0) then ShowCursor;
  886. end;
  887.  
  888.  
  889. procedure TUserScreen.HandleEvent(var Event: TEvent);
  890. begin
  891.   TScroller.HandleEvent(Event);
  892.   If (Owner^.State and sfModal <> 0) and (Event.What in [evKeyDown,evMouseDown]) then
  893.     begin
  894.     Owner^.EndModal(cmCancel);
  895.     ClearEvent(Event);
  896.     end;
  897. end;
  898.  
  899.  
  900. function  TUserScreen.Valid(Command: word) : boolean;
  901. begin
  902.   If (Command = cmValid) and (KeptScreen = nil) then
  903.     begin
  904.     MessageBox('User screen was not preserved.', nil, mfError + mfOKButton);
  905.     Valid := FALSE;
  906.     end
  907.    else
  908.     Valid := TScroller.Valid(Command);
  909. end;
  910.  
  911.  
  912.   { ══════════════════════════════════════════════════════════════════════ }
  913.  
  914.  
  915. procedure RegisterTVGizma;
  916. begin
  917.   RegisterType(RLtdFrame);
  918.   RegisterType(RLtdWindow);
  919. end;
  920.  
  921.  
  922.   { ══════════════════════════════════════════════════════════════════════ }
  923.  
  924.  
  925. End.
  926.